home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / DATABASE / OBJ1_2.ZIP;1 / ARCHIV.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-01-21  |  14.7 KB  |  516 lines
  1. {$D-,L-,I-,R-,S-,F-,B-,V-,O-,N-,E+,A+,X+}
  2. {$M $2000,0,0}
  3. {…ÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕª}
  4. {∫  Archiv  v2.03   Backup/Restore database utility      (TurboPascal v6.0)   ∫}
  5. {∫                  (c) 1991, JHK, JHK-Software, Piestany.                    ∫}
  6. {»ÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕÕº}
  7.  
  8. program Archiv;   {Warning! Boolean evaluation must be short circuit ($B-)}
  9.                   {Warning! Input output checking must be disabled ($I-)}
  10. uses
  11.   Crt,
  12.   Dos;
  13.  
  14.  
  15. {$IfDef ENGLISH}
  16. const
  17.   not_create     = 'Can''t create file ';
  18.   not_open       = 'Can''t open file ';
  19.   not_read       = 'Can''t read file ';
  20.   not_write      = 'Can''t write file ';
  21.   not_close      = 'Can''t close file ';
  22.   insert_new     = 'Insert new diskette ';
  23.   into_drive     = 'into drive ';
  24.   then_text      = 'then ';
  25.   press_key      = 'press any key...';
  26.   insert_archiv  = 'Insert archiv diskette ';
  27.   disk_full      = 'Disk full or not formatted!';
  28.   insert_another = 'Insert another disk and press <Enter>, or press <Esc> for Abort...';
  29.   canceled       = 'Canceled by operator!';
  30.   archiv_error   = 'Archiv error! ';
  31.   save_into      = 'Save files into ';
  32.   restore_from   = 'Restore files from ';
  33.   split          = '(split)';
  34.   continue       = '(continue)';
  35.   syntax1        = 'Syntax is: Archiv [/W[nnn]] /S[ave] InputFiles ArchivFile <Enter>';
  36.   syntax2        = '       or: Archiv [/W[nnn]] /L[oad] ArchivFile [OutputDir] <Enter>';
  37.   syntax3        = 'Wnnn: W=windowed_output; nnn=Dos_color_attribute_(0-255)';
  38.   done           = 'Done.';
  39.  
  40. {$Else}
  41.  
  42. const
  43.   not_create     = 'Nemozem vytvorit subor ';
  44.   not_open       = 'Nemozen otvorit subor ';
  45.   not_read       = 'Nemozem citat subor ';
  46.   not_write      = 'Nemozem zapisovat do suboru ';
  47.   not_close      = 'Nemozem zatvorit subor ';
  48.   insert_new     = 'Vlozte novu disketu ';
  49.   into_drive     = 'do mechaniky ';
  50.   then_text      = 'potom ';
  51.   press_key      = 'stlacte nejaku klavesu...';
  52.   insert_archiv  = 'Vlozte archivnu disketu ';
  53.   disk_full      = 'Disk(disketa) je plny alebo nenaformatovany!';
  54.   insert_another = 'Vlozte iny disk a stlacte <Enter>, alebo stlacte <Esc> pre koniec...';
  55.   canceled       = 'Ukoncene operatorom!';
  56.   archiv_error   = 'Chyba! ';
  57.   save_into      = 'Ulozenie suborov do ';
  58.   restore_from   = 'Obnovenie suborov z ';
  59.   split          = '(rozdeleny)';
  60.   continue       = '(pokracovanie)';
  61.   syntax1        = 'Syntax je: Archiv [/W[nnn]] /S[ave] VstupneSubory ArchivnySubor <Enter>';
  62.   syntax2        = '           Archiv [/W[nnn]] /L[oad] ArchivnySubor [VystupnyAdresar] <Enter>';
  63.   syntax3        = 'Wnnn: W=vystup_do_okna; nnn=Dos_cislo_farby_(0-256)';
  64.   done           = 'Ok.';
  65. {$EndIf}
  66.  
  67.  
  68. const
  69.   c_byte=221;          {magic compress byte indicator}
  70.   BufSize=4096+512;
  71.   cr_lf=#13#10;
  72.  
  73. type
  74.   TiBuf=array[1..BufSize+1] of Byte;
  75.   ToBuf=array[1..2*BufSize+1] of Byte;
  76.  
  77. const
  78.   ArchOpened:Boolean=false;
  79.   FreeSpace:LongInt=0;
  80.  
  81. var
  82.   iBuf:TiBuf;
  83.   oBuf:ToBuf;
  84.   Fi,Fo:File;
  85.   D,N,E:PathStr;      {directory info, see FSplit()}
  86.   S,FNi,FNo:String;
  87.   OutDir:PathStr;     {for Load}
  88.   UpPressKey:PathStr; {Upper case message "Press any key..."}
  89.  
  90.  
  91. procedure Abort(Msg:String);
  92. begin {Abort}
  93.   Write(cr_lf,archiv_error,Msg);
  94.   Write(cr_lf,UpPressKey);
  95.   ReadKey;
  96.   Halt(1);
  97. end;{Abort}
  98.  
  99.  
  100. procedure AbortPars;
  101. begin {AbortPars}
  102.   Write(cr_lf,syntax1);
  103.   Write(cr_lf,syntax2);
  104.   Write(cr_lf,syntax3);
  105.   Halt(1);
  106. end;{AbortPars}
  107.  
  108.  
  109. function StUpCase(S:String):String;
  110. var
  111.   I:Integer;
  112. begin {StUpCase}
  113.   for I:=1 to Length(S) do S[I]:=UpCase(S[I]);
  114.   StUpCase:=S;
  115. end;{StUpCase}
  116.  
  117.  
  118. function DiskSize(D:Char):LongInt;
  119. begin {DiskSize}
  120.   DiskSize:=DiskFree(Ord(UpCase(D))-Ord('A')+1)-2; {2 bytes for saving close info}
  121. end;{DiskSize}
  122.  
  123.  
  124. function S_OpenArchiv(FName:PathStr):LongInt;
  125. var
  126.   Ch:Char;
  127.   L:LongInt;
  128.   I,Code:Integer;
  129. begin {S_OpenArchiv}
  130.   if E<>'.001' then Write(' ',split);
  131.   if UpCase(FNo[1]) in ['A','B'] then begin
  132.     Write(cr_lf,insert_new,into_drive,UpCase(FNo[1]),': ',then_text,press_key);
  133.     ReadKey;
  134.   end;{if}
  135.   Assign(Fo,FNo);
  136.   ReWrite(Fo,1);
  137.   if IoResult<>0 then Abort(not_create+FNo);
  138.   L:=DiskSize(FNo[1]);
  139.   while L<512 do begin
  140.     Write(cr_lf,disk_full);
  141.     Write(cr_lf,insert_another);
  142.     repeat
  143.       Ch:=UpCase(ReadKey);
  144.     until Ch in [#13,#27];
  145.     if Ch=#27 then Abort(canceled);
  146.     Assign(Fo,FNo);
  147.     ReWrite(Fo,1);
  148.     if IoResult<>0 then Abort(not_create+FNo);
  149.     L:=DiskSize(FNo[1]);
  150.   end;{while}
  151.   S_OpenArchiv:=L;
  152.   ArchOpened:=true;
  153.   Write(cr_lf,save_into,FNo);
  154.   if E<>'.001' then Write(cr_lf,' ',FName,' ',continue);
  155. end;{S_OpenArchiv}
  156.  
  157.  
  158. procedure S_CloseArchiv(lContinue:Boolean);
  159. var
  160.   B:Byte;
  161.   i,Code:Integer;
  162. begin {S_CloseArchiv}
  163.   Val(Copy(E,2,3),B,Code);
  164.   Inc(B);
  165.   Str(B:3,E);
  166.   for i:=1 to Length(E) do if E[i]=' ' then E[i]:='0';
  167.   E:='.'+E;
  168.   FNo:=D+N+E;
  169.   FillChar(oBuf[1],2,0);
  170.   if lContinue then oBuf[2]:=B;
  171.   BlockWrite(Fo,oBuf,2,Code);
  172.   Close(Fo);
  173.   if (IoResult<>0)or(2<>Code) then Abort(not_close+FNo);
  174.   ArchOpened:=false;
  175. end;{S_CloseArchiv}
  176.  
  177.  
  178. function Compress(Bti:Word):Word;
  179. var
  180.   i,j,Bto:Word;
  181. begin {Compress}
  182.   i:=1;
  183.   j:=2;
  184.   Bto:=1;
  185.   while (i<=Bti) do begin
  186.     while (j<=Bti)and(iBuf[i]=iBuf[j]) do Inc(j);  {search unique bytes}
  187.     if (i+2)<j then begin {save block}
  188.       while i<j do begin
  189.         oBuf[Bto]:=c_byte;  Inc(Bto);   {magic compress byte indicator}
  190.         oBuf[Bto]:=iBuf[i]; Inc(Bto);   {origin byte}
  191.         if (j-i)>255 then begin
  192.           oBuf[Bto]:=255; Inc(Bto);     {count for orgin byte}
  193.           Inc(i,255);
  194.         end else begin
  195.           oBuf[Bto]:=j-i; Inc(Bto);     {count for orgin byte}
  196.           i:=j;
  197.         end;{if}
  198.       end;{while}
  199.       Inc(j);
  200.     end else if iBuf[i]=c_byte then begin {save bad block}
  201.       oBuf[Bto]:=c_byte; Inc(Bto);        {magic compress byte indicator}
  202.       oBuf[Bto]:=c_byte; Inc(Bto);        {origin byte}
  203.       oBuf[Bto]:=j-i; Inc(Bto);           {count for orgin byte}
  204.       i:=j;
  205.       Inc(j);
  206.     end else begin {save one/two byte(s)}
  207.       oBuf[Bto]:=iBuf[i]; Inc(Bto); Inc(i);
  208.       while i<j do begin
  209.         oBuf[Bto]:=iBuf[i]; Inc(Bto); Inc(i);
  210.       end;{while}
  211.       Inc(j);
  212.     end;{if}
  213.   end;{while}
  214.   Compress:=Bto-1;
  215. end;{Compress}
  216.  
  217.  
  218. function S_SaveBytes(W:LongInt):LongInt;  {return saved_bytes}
  219. var
  220.   Bti,Bto,Count:Word;
  221.   Saved:LongInt;
  222. begin {S_SaveBytes}
  223.   Saved:=0;
  224.   repeat
  225.     if BufSize<W then Bti:=BufSize else Bti:=W;
  226.     BlockRead(Fi,iBuf,Bti,Count);
  227.     if (IoResult<>0)or(Bti<>Count) then Abort(not_read+FNi);
  228.     Bto:=Compress(Bti);
  229.     BlockWrite(Fo,oBuf,Bto,Count);
  230.     if (IoResult<>0)or(Bto<>Count) then Abort(not_write+FNo);
  231.     Dec(W,Bti);
  232.     Inc(Saved,Bto);
  233.   until W=0;
  234.   S_SaveBytes:=Saved;
  235. end;{S_SaveBytes}
  236.  
  237.  
  238. procedure S_SaveFile(FName:PathStr);
  239. var
  240.   i:Integer;
  241.   Count:Word;
  242.   Wi,Wo,BytesNeedSave:LongInt;
  243.   SaveFName,SaveFExt,S:PathStr;
  244. begin {S_SaveFile}
  245.   Assign(Fi,FName);
  246.   Reset(Fi,1);
  247.   if IoResult<>0 then Abort(not_open+FName);
  248.   BytesNeedSave:=FileSize(Fi);
  249.   if not(ArchOpened) then
  250.     FreeSpace:=S_OpenArchiv(FName)
  251.   else begin
  252.     if FreeSpace<512 then begin
  253.       S_CloseArchiv(true);
  254.       FreeSpace:=S_OpenArchiv(FName);
  255.     end;{if}
  256.   end;{if}
  257.   Write(cr_lf,' ',FName);
  258.   FSplit(FName,S,SaveFName,SaveFExt);
  259.   SaveFName:=SaveFName+SaveFExt;
  260.   i:=Length(SaveFName);
  261.   Move(SaveFName,oBuf[1],i+1);
  262.   Move(BytesNeedSave,oBuf[i+2],4);   Inc(i,5);
  263.   BlockWrite(Fo,oBuf,i,Count);
  264.   if (IoResult<>0)or(i<>Count) then Abort(not_write+FNo);
  265.   repeat
  266.     if not(ArchOpened) then FreeSpace:=S_OpenArchiv(FName);
  267.     if FreeSpace<BytesNeedSave then Wi:=FreeSpace else Wi:=BytesNeedSave;
  268.     Wo:=S_SaveBytes(Wi);
  269.     Dec(BytesNeedSave,Wi);
  270.     Dec(FreeSpace,Wo);
  271.     if (FreeSpace<512)and(BytesNeedSave<>0) then S_CloseArchiv(true);
  272.   until BytesNeedSave=0;
  273.   Close(Fi);
  274. end;{S_SaveFile}
  275.  
  276.  
  277. procedure S_SaveMask(Mask:PathStr);
  278. var
  279.   Sr:SearchRec;
  280.   Di,Na,Ex:PathStr;
  281. begin {S_SaveMask}
  282.   FSplit(Mask,Di,Na,Ex);
  283.   FindFirst(Mask,AnyFile,Sr);
  284.   while DosError=0 do begin
  285.     if (Sr.Name[1]<>'.')and((Sr.Attr and $18)=0) then S_SaveFile(Di+Sr.Name);
  286.     FindNext(Sr);
  287.   end;{while}
  288. end;{S_SaveMask}
  289.  
  290.  
  291. procedure L_OpenArchiv;
  292. var
  293.   Ch:Char;
  294. begin {L_OpenArchiv}
  295.   Assign(Fi,FNi);
  296.   if UpCase(FNi[1]) in ['A','B'] then begin
  297.     Write(cr_lf,insert_archiv,Copy(E,2,3),' ',into_drive,UpCase(FNi[1]),': ',then_text,press_key);
  298.     ReadKey;
  299.     ReSet(Fi,1);
  300.     if IoResult<>0 then begin
  301.       repeat
  302.         Write(cr_lf,not_open,FNi);
  303.         Write(cr_lf,insert_another);
  304.         repeat
  305.           Ch:=UpCase(ReadKey);
  306.         until Ch in [#13,#27];
  307.         if Ch=#27 then Abort(canceled);
  308.         ReSet(Fi,1);
  309.       until IoResult=0;
  310.     end;{if}
  311.   end else begin  {hard disk}
  312.     ReSet(Fi,1);
  313.     if IoResult<>0 then Abort(not_open+FNi);
  314.   end;{if}
  315.   Write(cr_lf,restore_from,FNi);
  316.   if E<>'.001' then Write(cr_lf,' ',FNo,' ',continue);
  317. end;{L_OpenArchiv}
  318.  
  319.  
  320. function L_CloseArchiv:Boolean;
  321. var
  322.   B:Byte;
  323.   i,j,Code:Integer;
  324. begin {L_CloseArchiv}
  325.   BlockRead(Fi,I,2,Code);
  326.   Close(Fi);
  327.   if (IoResult<>0)or(2<>Code) then Abort(not_close+FNi);
  328.   L_CloseArchiv:=(I=0);
  329.   {}
  330.   Val(Copy(E,2,3),B,Code);      {next archiv extension}
  331.   Inc(B);
  332.   Str(B:3,E);
  333.   for j:=1 to Length(E) do if E[j]=' ' then E[j]:='0';
  334.   E:='.'+E;
  335.   FNi:=D+N+E;
  336. end;{L_CloseArchiv}
  337.  
  338.  
  339. var
  340.   FileOpened:Boolean;
  341.   NewFile:Boolean;
  342.   InitNewFile:Boolean;
  343.   OutBytes:LongInt;
  344.   FBytes:LongInt;
  345.   FSize:LongInt;
  346.   FSizeChar:String[5];
  347.   Bytes:Byte;
  348.   CompressFlag,CompressByte:Byte;
  349.  
  350. procedure L_BlockProcess(W:Word);
  351. var
  352.   B:Byte;
  353.   i,j:Word;
  354.   Count:Word;
  355.   FName,Di,Na,Ex:PathStr;
  356.   Po:Byte;
  357. begin {L_BlockProcess}
  358.   i:=0;
  359.   repeat
  360.     Inc(i);
  361.     B:=iBuf[i];
  362.     if NewFile then begin
  363.       if InitNewFile then begin
  364.         Bytes:=B+4;   {4 file len}
  365.         FSizeChar:='';
  366.         FNo:=OutDir;
  367.         FName:='';
  368.         InitNewFile:=false;
  369.       end else begin  {ProcessNewFile}
  370.         if Bytes>4 then begin  {get file name}
  371.           FNo:=FNo+Char(B);
  372.           FName:=FName+Char(B);
  373.           Dec(Bytes);
  374.         end else if Bytes>0 then begin  {get file size}
  375.           FSizeChar:=FSizeChar+Char(B);
  376.           Dec(Bytes);
  377.         end else begin  {open new file}
  378.           Write(cr_lf,' ',FNo);
  379.           Assign(Fo,FNo);
  380.           ReWrite(Fo,1);
  381.           if IoResult<>0 then begin {attempt create directory, if exist}
  382.             FSplit(FName,Di,Na,Ex);
  383.             if Di='' then Abort(not_create+FNo)  {not a directory}
  384.             else begin
  385.               Na:='';  {working directory names}
  386.               while Di<>'' do begin
  387.                 Po:=Pos('\',Di);    {find subdirs}
  388.                 Na:=Na+Copy(Di,1,Po-1);
  389.                 if Po<Length(Di) then Di:=Copy(Di,Po+1,Length(Di)-Po) else Di:='';
  390.                 MkDir(OutDir+Na);
  391.                 Na:=Na+'\';
  392.               end;{while}
  393.               ReWrite(Fo,1);
  394.               if IoResult<>0 then Abort(not_create+FNo);
  395.             end;{if}
  396.           end;{if}
  397.           Move(FSizeChar[1],FSize,4);
  398.           FBytes:=0;
  399.           NewFile:=false;
  400.           Dec(i);
  401.           if FSize=0 then begin {file length = 0}
  402.             Close(Fo);
  403.             if IoResult<>0 then Abort(not_close+FNo);
  404.             NewFile:=true;
  405.             InitNewFile:=true;
  406.             OutBytes:=1;
  407.           end;{if}
  408.         end;{if}
  409.       end;{if,InitNewFile}
  410.     end else begin {------------------------------------------- append byte }
  411.       if CompressFlag=1 then begin {save compress byte}
  412.         CompressByte:=B;
  413.         Inc(CompressFlag);
  414.       end else if CompressFlag=2 then begin {uncompress}
  415.         CompressFlag:=0;
  416.         FillChar(oBuf[OutBytes],B,CompressByte);
  417.         Inc(OutBytes,B);
  418.         Inc(FBytes,B);
  419.       end else if B=c_byte then CompressFlag:=1
  420.       else begin
  421.         oBuf[OutBytes]:=B;
  422.         if OutBytes>=(BufSize-512) then begin {WriteBlock}
  423.           BlockWrite(Fo,oBuf,OutBytes,Count);
  424.           if (IoResult<>0)or(OutBytes<>Count) then Abort(not_write+FNo);
  425.           OutBytes:=0;
  426.         end;{if}
  427.         Inc(OutBytes);
  428.         Inc(FBytes);
  429.       end;{if}
  430.       if FSize<=FBytes then begin  {close file}
  431.         Dec(OutBytes);
  432.         BlockWrite(Fo,oBuf,OutBytes,Count);
  433.         if (IoResult<>0)or(OutBytes<>Count) then Abort(not_write+FNo);
  434.         Close(Fo);
  435.         if IoResult<>0 then Abort(not_close+FNo);
  436.         NewFile:=true;
  437.         InitNewFile:=true;
  438.         OutBytes:=1;
  439.       end;{if}
  440.     end;{if,NewFile}
  441.   until i>=W;
  442. end;{L_BlockProcess}
  443.  
  444.  
  445. procedure L_ReadArchiv;
  446. var
  447.   Count:Word;
  448.   W,EofArchiv:LongInt;
  449. begin {L_ReadArchiv}
  450.   EofArchiv:=FileSize(Fi)-2;
  451.   while FilePos(Fi)<EofArchiv do begin {}
  452.     W:=EofArchiv-FilePos(Fi);
  453.     if W>BufSize then W:=BufSize;
  454.     BlockRead(Fi,iBuf,W,Count);
  455.     if (IoResult<>0)or(W<>Count) then Abort(not_read+FNi);
  456.     L_BlockProcess(W);
  457.   end;{while,FilePos}
  458. end;{L_ReadArchiv}
  459.  
  460.  
  461. var
  462.   PFirst,I,Code:Integer;
  463.  
  464.  
  465. begin {MAIN, Archiv}
  466.   System.FileMode:=$40;     {read_only, deny_none, inherited bu spawn...}
  467.   UpPressKey:=press_key;                             {"press any key..."}
  468.   UpPressKey[1]:=UpCase(UpPressKey[1]);              {"Press any key..."}
  469.   if ParamCount>=2 then begin
  470.     PFirst:=1; {assume, index into first parameter}
  471.     S:=StUpCase(ParamStr(PFirst));
  472.     if Copy(S,1,2)='/W' then begin {window switch, shift parameters}
  473.       Window(6,5,75,Mem[$0040:$0084]-3);
  474.       Val(Copy(S,3,Length(S)-2),I,Code);
  475.       if Code=0 then TextAttr:=I
  476.       else if LastMode=7 then TextAttr:=$07 else TextAttr:=$1E;  {bg+/b}
  477.       ClrScr;
  478.       PFirst:=2; {shift}
  479.       S:=StUpCase(ParamStr(PFirst));
  480.     end;{if}
  481.   end;{if}
  482.   Write('Archiv v2.03  Backup/Restore database utility');
  483.   Write(cr_lf,'Copyright (c) 1991, JHK, JHK-Software, Piestany. All rights reserved.');
  484.   if ParamCount<2 then AbortPars;
  485.   if Copy(S,1,2)='/S' then begin
  486.     FSplit(FExpand(ParamStr(ParamCount)),D,N,E);
  487.     if N='' then N:='Archiv';
  488.     E:='.001';
  489.     FNo:=D+N+E;
  490.     for I:=PFirst+1 to ParamCount-1 do S_SaveMask(ParamStr(I)); {main save loop}
  491.     if ArchOpened then S_CloseArchiv(false);
  492.   end else begin
  493.     FSplit(FExpand(ParamStr(PFirst+1)),D,N,E);
  494.     if N='' then N:='Archiv';
  495.     E:='.001';
  496.     FNi:=D+N+E;
  497.     OutDir:=FExpand(ParamStr(PFirst+2));
  498.     if OutDir[Length(OutDir)]<>'\' then OutDir:=OutDir+'\';
  499.     {}
  500.     NewFile:=true;
  501.     InitNewFile:=true;
  502.     OutBytes:=1;
  503.     FBytes:=0;
  504.     FSize:=0;
  505.     CompressFlag:=0;
  506.     repeat
  507.       L_OpenArchiv;
  508.       L_ReadArchiv;
  509.     until L_CloseArchiv;
  510.   end;{if}
  511.   Write(cr_lf,done);
  512.   Write(cr_lf,UpPressKey);
  513.   ReadKey;
  514. end.
  515.  
  516.